home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / low.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  119 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Low-level things that rely on the fact that we're running under the
  5. ; Scheme 48 VM.
  6.  
  7. ; Needs LET macro.
  8.  
  9.  
  10. ; Characters are not represented in ASCII.  Using a different encoding
  11. ; helps to catch portability problems.
  12.  
  13. (define (char->integer c) (+ (char->ascii c) 1000))
  14. (define (integer->char n) (ascii->char (- n 1000)))
  15.  
  16. (define ascii-limit 256)        ;for reader
  17. (define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
  18.  
  19.  
  20. ; Procedures and closures are two different abstractions.  Procedures
  21. ; are created by LAMBDA and invoked with procedure call; those are
  22. ; their only defined operations.  Closures are made with MAKE-CLOSURE,
  23. ; accessed using CLOSURE-TEMPLATE and CLOSURE-ENV, and invoked by
  24. ; INVOKE-CLOSURE, which starts the virtual machine going.
  25.  
  26. ; In a running Scheme 48 system, the two happen to be implemented
  27. ; using the same data type.  The following is the only part of the
  28. ; system that should know this fact.
  29.  
  30. (define procedure? closure?)
  31.  
  32. (define (invoke-closure closure . args)
  33.   (apply (loophole :procedure closure)
  34.      args))
  35.  
  36.  
  37. ; Similarly, there are escapes and there are VM continuations.
  38. ; Escapes are obtained with PRIMITIVE-CWCC and invoked with
  39. ; WITH-CONTINUATION.  VM continuations are obtained with
  40. ; PRIMITIVE-CATCH and inspected using CONTINUATION-REF and friends.
  41. ; (This is not such a hot naming strategy; it would perhaps be better
  42. ; to use the terms "continuation" and "frame".)
  43.  
  44. ; In a running Scheme 48 system, the two happen to be implemented
  45. ; using the same data type.  The following is the only part of the
  46. ; system that should know this fact.
  47.  
  48. (define (primitive-cwcc p)
  49.   (primitive-catch (lambda (cont)
  50.              (p (loophole :escape cont))))) ;?
  51.  
  52. ; (define (invoke-continuation cont thunk)
  53. ;   (with-continuation (loophole :escape cont) thunk))
  54.  
  55.  
  56. ; These two procedures are part of the location abstraction.
  57.  
  58. (define (make-undefined-location id)
  59.   (let ((loc (make-location #f id)))
  60.     (set-location-defined?! loc #f)
  61.     loc))
  62.  
  63. (define (vector-unassigned? v i)
  64.   (eq? (vector-ref v i) (unassigned)))
  65.  
  66.  
  67. ; STRING-COPY is here because it's needed by STRING->SYMBOL.
  68.  
  69. (define (string-copy s)
  70.   (let ((z (string-length s)))
  71.     (let ((copy (make-string z #\space)))
  72.       (let loop ((i 0))
  73.     (cond ((= i z) copy)
  74.           (else
  75.            (string-set! copy i (string-ref s i))
  76.            (loop (+ i 1))))))))
  77.  
  78.  
  79. ; The symbol table
  80.  
  81. (define (string->symbol string)
  82.   (if (eq? *the-symbol-table* #f)
  83.       (restore-the-symbol-table!))
  84.   (intern (if (immutable? string)
  85.           string            ;+++
  86.           (make-immutable! (string-copy string)))
  87.       *the-symbol-table*))
  88.  
  89. (define *the-symbol-table* #f)
  90.  
  91. (define (flush-the-symbol-table!)
  92.   (set! *the-symbol-table* #f))
  93.  
  94. (define (restore-the-symbol-table!)
  95.   (set! *the-symbol-table* (make-vector 1024 '()))
  96.   (find-all-symbols *the-symbol-table*))
  97.  
  98. (restore-the-symbol-table!)
  99.  
  100.  
  101. ; I/O
  102.  
  103. (define (maybe-open-input-file string)
  104.   (open-port string 1))            ;(define for-input 1)
  105.  
  106. (define (maybe-open-output-file string)
  107.   (open-port string 2))            ;(define for-output 2)
  108.  
  109. (define (open-input-file string)
  110.   (or (maybe-open-input-file string)
  111.       (error "can't open for input" string)))
  112.  
  113. (define (open-output-file string)
  114.   (or (maybe-open-output-file string)
  115.       (error "can't open for output" string)))
  116.  
  117. (define close-input-port  close-port)
  118. (define close-output-port close-port)
  119.